(GLOBAL (FUNCTIONS MATCH ASSIGNED?) (RESERVED !> !< !' !? !; !/,))

(DECLARE (SYMBOLS T)
	 (GENPREFIX (QUOTE \M))
	 (GENSYM (QUOTE M))
	 (SPECIAL MALIST
 		  MALIST1
 		  MALIST2
 		  MALISTV1
 		  MALISTV2
 		  NOBIND
 		  VALV)
	 (*LEXPR MATCH TRYASSIGN RVALUE VLOC)
	 (*FEXPR CERR))

(DEFPROP MATCH
	 (LAMBDA N
	  ((LAMBDA(VARPAT DATAPAT)
	    (PROG (MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND)
		  (COND
		   ((> N 2) (SETQ MALIST1 (ARG 3))
			    (SETQ MALIST2 (ARG 4))
			    (SETQ NOBIND T)))
		  (SETQ MALISTV1 (GET (QUOTE MALIST1) (QUOTE VALUE)))
		  (SETQ MALISTV2 (GET (QUOTE MALIST2) (QUOTE VALUE)))
		  (RETURN
		   (COND
		    ((MATCH1 VARPAT DATAPAT)
		     (LIST MALIST1 MALIST2))))))
	   (ARG 1)
	   (ARG 2)))
 	 EXPR)

(DECLARE (UNSPECIAL MALIST1 MALIST2))

(DEFPROP MATCH1
	 (LAMBDA(VARPAT DATAPAT)
	  (PROG (ACTOR1 ACTOR2)
		(RETURN
		 (COND ((ATOM VARPAT)
			(MATCH2 DATAPAT VARPAT MALISTV2))
		       ((ATOM DATAPAT)
			(MATCH2 VARPAT DATAPAT MALISTV1))
		       ((EQ (SETQ ACTOR2 (CAR DATAPAT)) (QUOTE !')))
		       ((MEMQ ACTOR2 (QUOTE (!< !?)))
			(MATCH2 VARPAT
				(ACTORSUBST DATAPAT (CDR MALISTV2))
 				MALISTV1))
		       ((EQ (SETQ ACTOR1 (CAR VARPAT)) (QUOTE !>))
			(!> (CDR VARPAT) DATAPAT MALISTV1 MALISTV2))
		       ((EQ ACTOR1 (QUOTE !?))
			(!? (CDR VARPAT)
 			    DATAPAT
 			    MALISTV1
 			    MALISTV2
 			    T))
		       ((EQ ACTOR1 (QUOTE !'))
			(MBINDR (CADR VARPAT)
				(CDDR VARPAT)
 				DATAPAT
 				MALISTV1))
		       ((EQ ACTOR1 (QUOTE !<))
			(!< (CADR VARPAT) DATAPAT MALISTV1 MALISTV2))
		       ((EQ ACTOR1 (QUOTE !/,))
			(COMMA (CDR VARPAT)
 			       DATAPAT
 			       MALISTV1
 			       MALISTV2))
		       ((EQ ACTOR1 (QUOTE !;))
			(!; (CDR VARPAT)
 			    DATAPAT
 			    MALISTV1
 			    MALISTV2
 			    T))
		       ((EQ ACTOR2 (QUOTE !>))
			(!? (CDR DATAPAT)
 			    VARPAT
 			    MALISTV2
 			    MALISTV1
 			    NIL))
		       ((EQ ACTOR2 (QUOTE !;))
			(!; (CDR DATAPAT)
 			    VARPAT
 			    MALISTV2
 			    MALISTV1
 			    NIL))
		       ((EQ ACTOR2 (QUOTE !/,))
			(COMMA (CDR DATAPAT)
 			       VARPAT
 			       MALISTV2
 			       MALISTV1))
		       ((MATCH1 (CAR VARPAT) (CAR DATAPAT))
			(MATCH1 (CDR VARPAT) (CDR DATAPAT)))))))
 	 EXPR)

(DECLARE (UNSPECIAL MALISTV2))

(DEFPROP COMMA
	 (LAMBDA(VARSPEC DATAPAT MV1 MV2)
	  ((LAMBDA(VAR VALSPEC)
	    (COND
	     (VALSPEC
	      ((LAMBDA(VAL)
		(COND
		 ((MATCH2 DATAPAT VAL MV2) (MBINDV VAR VAL MV1))))
	       ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MV1))))
	     (((LAMBDA(VAL)
		(COND
		 ((EQ VAL (QUOTE *UNASSIGNED))
		  (TRYASSIGN VAR
 			     DATAPAT
			     (CDR MV1)
 			     MV2
			     (EQ MV1 MALISTV1)
 			     NIL))
		 ((MATCH2 DATAPAT VAL MV2))))
	       ((LAMBDA (MALIST) (!/,1 VAR)) (CDR MV1))))))
	   (CAR VARSPEC)
	   (CDR VARSPEC)))
 	 EXPR)

(DECLARE (UNSPECIAL MALISTV1))

(DEFPROP MATCH2
	 (LAMBDA(VARPAT EXP MV)
	  (COND ((ATOM VARPAT) (EQUAL VARPAT EXP))
		(((LAMBDA(ACTOR)
		   (COND
		    ((MEMQ ACTOR (QUOTE (!? !> !')))
		     (MBINDR (CADR VARPAT) (CDDR VARPAT) EXP MV))
		    ((EQ ACTOR (QUOTE !/,))
		     ((LAMBDA(VAR VALSPEC)
		       (COND
			(VALSPEC
			 ((LAMBDA(VAL)
			   (COND
			    ((EQUAL VAL EXP) (MBINDV VAR EXP MV))))
			  ((LAMBDA (MALIST) (EVAL (CAR VALSPEC)))
			   (CDR MV))))
			(((LAMBDA(VAL)
			   (COND
			    ((EQ VAL (QUOTE *UNASSIGNED))
			     (MSET VAR EXP (CDR MV)))
			    ((EQUAL VAL EXP))))
			  ((LAMBDA (MALIST) (!/,1 VAR)) (CDR MV))))))
		      (CADR VARPAT)
		      (CDDR VARPAT)))
		    ((EQ ACTOR (QUOTE !;))
		     (PROG (VAR VALV RS)
			   (SETQ VAR (CADR VARPAT))
			   (SETQ RS (CDDR VARPAT))
			   (RETURN
			    (COND
			     ((SETQ VALV (ASSQ VAR (CDR MV)))
			      (AND
			       (COND
				((EQ (SETQ VALV (CADR VALV))
				     (QUOTE *UNASSIGNED))
				 (MSET VAR EXP (CDR MV)))
				((EQUAL VALV EXP)))
			       (SATISFY RS (CDR MV))))
			     ((CHECKVAL VAR)
			      (AND (EQUAL VALV EXP)
				   (SATISFY RS (CDR MV))))
			     ((MBINDR VAR RS EXP MV))))))
		    ((EQ ACTOR (QUOTE !<)) NIL)
		    ((ATOM EXP) NIL)
		    ((MATCH2 ACTOR (CAR EXP) MV)
		     (MATCH2 (CDR VARPAT) (CDR EXP) MV))))
		  (CAR VARPAT)))))
 	 EXPR)

(DEFPROP !?
	 (LAMBDA(VARSPEC PAT VALISTV PALISTV VARSALLOWED)
	  ((LAMBDA(VAR RS VARS)
	    (COND
	     (VARS
	      (COND
	       ((OR VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
		(COND ((HASVARS VARS)
		       (MBINDV VAR (QUOTE *UNASSIGNED) VALISTV))
		      ((OR (NOT VAR)
			   (MBINDR VAR
 				   RS
				   (VARSUBST PAT (CDR PALISTV))
 				   VALISTV)))))))
	     (T (MBINDR VAR RS PAT VALISTV))))
	   (CAR VARSPEC)
	   (CDR VARSPEC)
	   (FINDVARS PAT PALISTV)))
 	 EXPR)

(DEFPROP !>
	 (LAMBDA(VARSPEC PAT VALISTV PALISTV)
	  ((LAMBDA(VAR RS VARS)
	    (COND (VARS
		   (COND ((HASVARS VARS) NIL)
			 (T
			  (OR (NOT VAR)
			      (MBINDR VAR
 				      RS
				      (VARSUBST PAT (CDR PALISTV))
 				      VALISTV)))))
		  (T (MBINDR VAR RS PAT VALISTV))))
	   (CAR VARSPEC)
	   (CDR VARSPEC)
	   (FINDVARS PAT PALISTV)))
 	 EXPR)
(DEFPROP TRYASSIGN
	 (LAMBDA N
	  ((LAMBDA(VARS VAR PAT MALIST PALISTV VARSALLOWED RS)
	    (COND
	     (VARS
	      (COND
	       ((OR VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
		(COND ((HASVARS VARS))
		      (T
		       ((LAMBDA(VAL)
			 (PROG NIL
			       (MSET VAR VAL MALIST)
			       (RETURN (SATISFY RS MALIST))))
			(VARSUBST PAT (CDR PALISTV))))))))
	     (T (MSET VAR PAT MALIST) (SATISFY RS MALIST))))
	   (FINDVARS (ARG 2) (ARG 4))
	   (ARG 1)
	   (ARG 2)
	   (ARG 3)
	   (ARG 4)
	   (ARG 5)
	   (ARG 6)))
 	 EXPR)

(DEFPROP !<
	 (LAMBDA(VAR PAT VALISTV PALISTV)
	  ((LAMBDA(VARS)
	    (COND
	     (VARS
	      (COND
	       ((HASVARS VARS)
		(OR (NOT VAR)
		    (MBIND VAR
			   (VARSUBST PAT (CDR PALISTV))
 			   VALISTV)))))))
	   (FINDVARS PAT PALISTV)))
 	 EXPR)

(DEFPROP !;
	 (LAMBDA(VARSPEC PAT VALISTV PALISTV MUSTBIND)
	  (PROG (VAR VALV RS)
		(SETQ VAR (CAR VARSPEC))
		(SETQ RS (CDR VARSPEC))
		(RETURN
		 (COND
		  ((SETQ VALV (ASSQ VAR (CDR VALISTV)))
		   (COND
		    ((EQ (SETQ VALV (CADR VALV)) (QUOTE *UNASSIGNED))
		     (TRYASSIGN VAR
 				PAT
				(CDR VALISTV)
 				PALISTV
 				MUSTBIND
 				RS))
		    ((MATCH2 PAT VALV PALISTV)
		     (SATISFY RS (CDR VALISTV)))))
		  ((CHECKVAL VAR)
		   (AND (MATCH2 PAT VALV PALISTV)
			(SATISFY RS (CDR VALISTV))))
		  (MUSTBIND (!> VARSPEC PAT VALISTV PALISTV))
		  ((!? VARSPEC PAT VALISTV PALISTV NIL))))))
 	 EXPR)

(DEFPROP CHECKVAL
	 (LAMBDA(VAR)
	  (COND
	   ((SETQ VALV (VLOC VAR))
	    (NOT (EQ (SETQ VALV (CADR VALV)) (QUOTE *UNASSIGNED))))
	   ((SETQ VALV (BOUNDP VAR))
	    (NOT (EQ (SETQ VALV (CDR VALV)) (QUOTE *UNASSIGNED))))))
 	 EXPR)

(DECLARE (UNSPECIAL VALV))

(DEFPROP FINDVARS
	 (LAMBDA(PAT MALISTV)
	  (COND ((ATOM PAT) NIL)
		(((LAMBDA(CAR)
		   (COND
		    ((EQ CAR (QUOTE !/,))
		     ((LAMBDA(VAR VALSPEC)
		       (COND
			((OR (NULL VALSPEC) NOBIND)
			 (GETSPEC (QUOTE !/,) VAR (CDR MALISTV)))
			((MBINDV VAR
				 ((LAMBDA(MALIST)
				   (EVAL (CAR VALSPEC)))
				  (CDR MALISTV))
 				 MALISTV)
			 (LIST (QUOTE NIL)))))
		      (CADR PAT)
		      (CDDR PAT)))
		    ((EQ CAR (QUOTE !;))
		     ((LAMBDA(VAR MALIST)
		       (COND
			((ASSIGNED? VAR) (LIST NIL))
			((OR NOBIND (ASSQ VAR MALIST))
			 (GETSPEC (QUOTE !;) VAR MALIST))
			((MBINDV VAR (QUOTE *UNASSIGNED) MALISTV)
			 (LIST (QUOTE !>)))))
		      (CADR PAT)
		      (CDR MALISTV)))
		    ((ACTOR CAR)
		     (COND (NOBIND
			    (GETSPEC CAR (CADR PAT) (CDR MALISTV)))
			   ((MBINDV (CADR PAT)
				    (QUOTE *UNASSIGNED)
 				    MALISTV)
			    (LIST CAR))))
		    ((NCONC (FINDVARS CAR MALISTV)
			    (FINDVARS (CDR PAT) MALISTV)))))
		  (CAR PAT)))))
 	 EXPR)

(DEFPROP HASMUSTASSIGNS
	 (LAMBDA(VARS)
	  (DO V
 	      VARS
	      (CDR V)
	      (NULL V)
	      (AND (MEMQ (CAR V) (QUOTE (!> !'))) (RETURN T))))
 	 EXPR)

(DEFPROP HASVARS
	 (LAMBDA(VARS)
	  (DO V VARS (CDR V) (NULL V) (AND (CAR V) (RETURN T))))
 	 EXPR)

(DEFPROP VARSUBST
	 (LAMBDA(PAT MALIST)
	  (COND ((ATOM PAT) PAT)
		((ACTOR (CAR PAT)) (ACTORSUBST PAT MALIST))
		((CONS (VARSUBST (CAR PAT) MALIST)
		       (VARSUBST (CDR PAT) MALIST)))))
 	 EXPR)

(DEFPROP ACTOR
	 (LAMBDA (ATOM) (MEMQ ATOM (QUOTE (!> !? !' !< !/, !;))))
 	 EXPR)
(DEFPROP ACTORSUBST
	 (LAMBDA(PAT MALIST)
	  ((LAMBDA(VAR)
	    ((LAMBDA(VAL)
	      (COND ((EQ VAL (QUOTE *UNASSIGNED)) PAT) (VAL)))
	     (!/,1 VAR)))
	   (CADR PAT)))
 	 EXPR)

(DEFPROP GETSPEC
	 (LAMBDA(ACTOR VAR MALIST)
	  (COND
	   ((EQ (!/,1 VAR) (QUOTE *UNASSIGNED))
	    (COND (NOBIND (CERR UNASSIGNED VARIABLE IN INSTANCE))
		  ((LIST ACTOR))))
	   ((LIST NIL))))
 	 EXPR)

(DEFPROP MBIND
	 (LAMBDA(VAR VAL ALISTV)
	  (COND (NOBIND (MSET VAR VAL (CDR ALISTV)))
		((RPLACD ALISTV
			 (CONS (LIST VAR VAL) (CDR ALISTV))))))
 	 EXPR)

(DEFPROP MBINDV
	 (LAMBDA(VAR VAL ALISTV)
	  (COND ((NOT VAR))
		(NOBIND (MSET VAR VAL (CDR ALISTV)))
		((RPLACD ALISTV
			 (CONS (LIST VAR VAL) (CDR ALISTV))))))
 	 EXPR)

(DECLARE (UNSPECIAL NOBIND))

(DEFPROP MBINDR
	 (LAMBDA(VAR RESTRICTIONS VAL ALISTV)
	  (OR (NOT VAR)
	      (AND (MBIND VAR VAL ALISTV)
		   (SATISFY RESTRICTIONS (CDR ALISTV)))))
 	 EXPR)

(DEFPROP !/, (LAMBDA (L) (!/,1 (CAR L))) FEXPR)

(DEFPROP !/,1
	 (LAMBDA(VAR/ )
	  ((LAMBDA (PAIR) (COND (PAIR (CADR PAIR)) ((RVALUE VAR/ ))))
	   (ASSQ VAR/  MALIST)))
 	 EXPR)

(DEFPROP SATISFY
	 (LAMBDA (RS MALIST) (OR (NULL RS) (APPLY (QUOTE AND) RS)))
 	 EXPR)

(DECLARE (UNSPECIAL MALIST))
(DEFPROP MSET
	 (LAMBDA(VAR VAL MALIST)
	  ((LAMBDA(PAIR)
	    (PROG NIL
		  (COND (PAIR (RPLACA (CDR PAIR) VAL) VAL)
			((CERR VARIABLE
 			       @VAR
 			       UNBOUND
 			       IN
 			       MATCH
 			       ALIST)))
		  (RETURN T)))
	   (ASSQ VAR MALIST)))
 	 EXPR)

(DEFPROP ASSIGNED?
	 (LAMBDA(VAR)
	  (PROG (VAL)
		(RETURN
		 (COND
		  ((SETQ VAL (VLOC VAR))
		   (NOT (EQ (CADR VAL) (QUOTE *UNASSIGNED))))
		  ((SETQ VAL (BOUNDP VAR))
		   (NOT (EQ (CDR VAL) (QUOTE *UNASSIGNED))))))))
 	 EXPR)